Suplementary material: Generalized method of moments and identifiability

knitr::opts_chunk$set(echo = TRUE)
library(latex2exp)
library(IsoPriceR)
library(ggplot2)
library(latex2exp)
library(kableExtra)
library(xtable)
setwd(dirname(rstudioapi::getActiveDocumentContext()$path))
getwd()

[1] "/Users/goffard/code/market_based_insurance_ratemaking/notebooks"

Let \(X\) be a random variable that represents the total health related over a given time period, say one year, associated to a pet. Our goal is to find the parameter \(\theta\) that best explains our market data made of insurance quotes \[ \tilde{p}_i = f_i\left[\mathbb{E}(g_i(X))\right],\text{ }i = 1,\ldots, n, \] where \(g_i\) are the coverage functions and \(f_i\) are the loading function. The coverage functions are known and of the form \[ g(x) = \min(\max(r\cdot x - d, 0), l), \] where \(r\) is the rate of coverage, \(d\) is the deductible and \(l\) is the limit.The loading functions are unknown and will be approximated by a generic function \(f\).

In the first section we consider the problem of finding \(\theta\) if we know access to the pure premiums

\[ p_i = \left[\mathbb{E}(g_i(X))\right],\text{ }i = 1,\ldots, n, \] which is not a realistic situation in practice. We then consider an isotonic regression model to approximate \(f\) and compares it to a parametric curve, linear withe \(f(x) = a + b\cdot x\) for simplicity. We consider an example where

\[ X = \sum_{k=1}^NU_k, \] where \(N\sim\text{Pois}(\lambda = 3)\) and the \(U_k\) are iid and lognormally distributed \(U\sim\text{LogNormal}(\mu =0 , \sigma = 1)\)

set.seed(142)

# Loss model
freq_dist <- model("poisson", c("lambda"))
sev_dist <- model("lognormal", c("mu", "sigma"))
l_m <- loss_model(freq_dist, sev_dist, "Poisson-Lognormal")

# True parameter
lambda_true <- 3; mu_true <- 0; sigma_true <- 1
true_parms <- t(as.matrix(c(lambda_true, mu_true, sigma_true)))
colnames(true_parms) <- l_m$parm_names

# Data
## Sample of claim data to calculate the true pure premium via Monte Carlo
X_true <- sample_X(l_m, true_parms, R = 10000)
summary(X_true)

       V1        
 Min.   : 0.000  
 1st Qu.: 1.705  
 Median : 3.765  
 Mean   : 4.946  
 3rd Qu.: 6.772  
 Max.   :76.830  

I - Generalized method of moments

If the pure premiums

\[ p_i = \mathbb{E}_(g_i(X)),\text{ }i = 1,\ldots, n, \]

are available then our estimation problem becomes find \(\theta\) that minimizes

\[ d\left[p_{1:n},p_{1:n}^\theta\right] = \sum_i w_i^{RMSE}(p_i -p_i^\theta)^2, \]

where \(p_i^\theta = \mathbb{E}_{\theta}(g_i(X))\). Identifiability holds if there exists a unique \(\theta^*\) such that

\[ \theta^* = \underset{\theta\in \Theta}{\text{argmin}}\, d\left[p_{1:n},p_{1:n}^\theta\right]. \]

This condition ressembles the global identification conditions of the Generalized Method of Moments which is typically hard to show. Existence of minimum requires that \(\theta\mapsto d\left[p_{1:n},p_{1:n}^\theta\right]\) is continuous and that \(\Theta\) is compact. Uniqueness would then hold if \(\theta\mapsto d\left[p_{1:n},p_{1:n}^\theta\right]\) is strictly convex. This condition is difficult to verify because an analytical expression of \(\theta\mapsto d\left[p_{1:n},p_{1:n}^\theta\right]\) is out of our reach and this for almost all the compound sum \(X\). A necessary condition is that the dimension of \(\theta\) is lower than \(n\) which is the number of moments we hold. Let us consider the case \(n = 3\) with

\[ g_1 = 0.85\cdot X\text{, } g_2 = \max(X - 1.8, 0) \text{, and }g_3 = \min(X, 6) \]

it is equivalent to the coverages \((r_1 = 0.85, d_1 = 0, l_1 = \infty)\), \((r_2 = 1, d_2 = 1.8, l_2 = \infty)\), and \((r_3 = 1, d_3 = 0, l_3 = 6)\).

## Characteristics of the pure premium which depends on the parameter of the insurance coverage
p_p <- pure_premium("xs", c("r", "d", "l"))
## Random premium parameters
n <- 3; r <- c(0.75, 1, 1); d <- c(0, 1.8, 0); l <- c(Inf, Inf, 6)

## Data frame with the insurance coverage parameters and the pure premium
th_premium <- matrix(c(r, d, l), nrow = n)
pps <- compute_pure_premia(X_true, coverage_type = "xs", th_premium)
sds <- sd_pure_premia(X_true, coverage_type = "xs", th_premium)
df_pp <- data.frame(r = r, d = d, l = l, pp=pps)
df_pp

latex_code <- xtable(df_pp)
print(latex_code, include.rownames = FALSE)

% latex table generated in R 4.4.2 by xtable 1.8-4 package
% Tue Jan 28 16:56:33 2025
\begin{table}[ht]
\centering
\begin{tabular}{rrrr}
  \hline
r & d & l & pp \\ 
  \hline
0.75 & 0.00 & Inf & 3.71 \\ 
  1.00 & 1.80 & Inf & 3.40 \\ 
  1.00 & 0.00 & 6.00 & 3.63 \\ 
   \hline
\end{tabular}
\end{table}

The pure premium computed above corresponds to a well specified case where there exists \(\theta^* = \theta_0\) for which

\[ d\left[p_{1:n},p_{1:n}^{\theta^{\ast}}\right] = 0 \] Note that we assign the same weight to each if the pre premium. We can check the uniqueness empirically, first in one dimension as we plot the functions \(\sigma\mapsto d\left[p_{1:n},p_{1:n}^{\theta^{\ast}}\right]\Big\rvert_{\mu =0, \lambda = 3}\), \(\mu\mapsto d\left[p_{1:n},p_{1:n}^{\theta^{\ast}}\right]\Big\rvert_{\sigma =1, \lambda = 3}\), and \(\lambda\mapsto d\left[p_{1:n},p_{1:n}^{\theta^{\ast}}\right]\Big\rvert_{\mu =0, \sigma = 1}\)

data <- df_pp[,c("r", "d", "l")]
data["x"] <- df_pp$pp
ths_premium <- as.matrix(data[p_p$parm_names])
lambda_true <- 3; mu_true <- 0; sigma_true <- 1

# Sigma --------------
# Pure premium calculation for a range of risk model parameters
sigmas <- seq(0.1, 2, 0.1)
cloud <- as.matrix(expand.grid(c(3), c(0),sigmas))
colnames(cloud) <- l_m$parm_names
X <- sample_X(l_m , cloud, R = 10000)
pp_fake <- compute_pure_premia(X, coverage_type = "xs", ths_premium)
                                                                     
# Calculation of the RMSE between true and wrong pure premium
ds <- sapply(1:nrow(cloud), function(k) mean((pp_fake[, k] - data$x)^2)^(1/2)) 
df_ds <- data.frame(cloud)
df_ds <- cbind(df_ds, ds)
(sig_pure_RMSE <- ggplot(data = df_ds) + geom_line(mapping = aes(x = sigma, y = ds)) +  ggplot2::theme_classic(base_size = 14) + labs(x = expression(sigma), title = "RMSE", y = "") )
ggsave("../figures/sig_pure_RMSE.pdf", sig_pure_RMSE)

Saving 7.29 x 4.51 in image

# Lambda --------------
lambdas <- seq(0.1, 5, 0.1)
cloud <- as.matrix(expand.grid(lambdas, c(0),c(1)))
colnames(cloud) <- l_m$parm_names
X <- sample_X(l_m , cloud, R = 10000)
pp_fake <- compute_pure_premia(X, coverage_type = "xs", ths_premium)
                                                                     
# Calculation of the RMSE between true and wrong pure premium
ds <- sapply(1:nrow(cloud), function(k) mean((pp_fake[, k] - data$x)^2)^(1/2)) 
df_ds <- data.frame(cloud)
df_ds <- cbind(df_ds, ds)
(lambda_pure_RMSE <- ggplot(data = df_ds) + geom_line(mapping = aes(x = lambda, y = ds)) +  ggplot2::theme_classic(base_size = 14) + labs(x = expression(lambda), title = "RMSE", y = "") )
ggsave("../figures/lambda_pure_RMSE.pdf", lambda_pure_RMSE)

Saving 7.29 x 4.51 in image

# mu --------------
mus <- seq(-3, 3, 0.1)
cloud <- as.matrix(expand.grid(c(3), mus,c(1)))
colnames(cloud) <- l_m$parm_names
X <- sample_X(l_m , cloud, R = 10000)
pp_fake <- compute_pure_premia(X, coverage_type = "xs", ths_premium)
                                                                     
# Calculation of the RMSE between true and wrong pure premium
ds <- sapply(1:nrow(cloud), function(k) mean((pp_fake[, k] - data$x)^2)^(1/2)) 
df_ds <- data.frame(cloud)
df_ds <- cbind(df_ds, ds)
(mu_pure_RMSE <- ggplot(data = df_ds) + geom_line(mapping = aes(x = mu, y = ds)) +  ggplot2::theme_classic(base_size = 14) + labs(x = expression(mu), title = "RMSE", y = "") )
ggsave("../figures/mu_pure_RMSE.pdf", mu_pure_RMSE)

Saving 7.29 x 4.51 in image

Each parameters can be identified separately, now of course identifying them jointly is another matter, there might exists several combinations of parameters that yield the same pure premium. Our optimization allows us to investigate by searching efficiently the parameter space.

We use the follwing prior assumptions: \[ \lambda\sim\text{Unif}(0, 10)\text{, }\mu\sim\text{Unif}(-3, 3)\text{, and }\sigma\sim\text{Unif}(0, 5) \] and the following settings for the algorithm

\[ J = 500\text{ and }R = 500 \] Recall that \(J\) is the population size of the clouds of particles and \(R\) is the number of Monte Carlo replications.

# Prior settings for the parameters
prior_lambda <- prior_dist("uniform", "lambda",c(0, 10))
prior_mu <- prior_dist("uniform", "mu",c(-3,3))
prior_sigma <- prior_dist("uniform", "sigma", c(0, 5))
prior_distributions <- list(prior_lambda, prior_mu, prior_sigma)
model_prior <- independent_priors(prior_distributions)

# Settings for the abc algorithm
popSize <- 500;  MC_R<- 500; acc <- 0.01; sp_bounds <- c(1, 1); eps_min <- 0.02

sum(sds/sqrt(MC_R)^2)

[1] 0.02037392

data <- df_pp[,c("r", "d", "l")]
data["x"] <- df_pp$pp
# res_abc <- abc(data, model_prior, l_m, p_p, popSize, MC_R, acc, sp_bounds, eps_min)
# save(res_abc, file = "../data/res_abc_supp_material_Section1.RData")

load("../data/res_abc_supp_material_Section1.RData")
# We retrieve the cloud of particles associated to each generation
cloud_dfs <- lapply(res_abc$Clouds, as.data.frame)
cloud_df <- do.call(rbind, cloud_dfs)
cloud_df$generation <- sort(rep(1:length(res_abc$Clouds), popSize))
cloud_df_plot <- rbind(
  data.frame(parm = cloud_df$lambda, parm_name = "lambda", generation = cloud_df$generation),
  data.frame(parm = cloud_df$sigma, parm_name = "sigma", generation = cloud_df$generation)
)
cloud_df_plot$parm_name <-as.factor(cloud_df_plot$parm_name) 
levels(cloud_df_plot$parm_name) <- c(lambda = TeX("$\\lambda$"), sigma = TeX("$\\sigma$"))

(posterior_lambda <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=lambda, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\lambda$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,1]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_lambda_supp_mat.pdf", posterior_lambda)

Saving 7.29 x 4.51 in image

(posterior_mu <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=mu, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\mu$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,2]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_mu_supp_mat.pdf", posterior_mu)

Saving 7.29 x 4.51 in image

(posterior_sig <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=sigma, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\sigma$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,3]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_sig_supp_mat.pdf", posterior_sig)

Saving 7.29 x 4.51 in image

II - Optimization based on the commercial premiums without regularization

We do not have access to the pure premium, instead we have the commercial premiums

\[ \tilde{p}_i = f_i\left[\mathbb{E}(g_i(X))\right],\text{ }i = 1,\ldots, n, \]

where the loading functions must be approximated. We therefore have to choose a model \(f\) such that

\[ \tilde{p}_i = f(p_{i}^\theta),\text{ }i = 1,\ldots, n \] and hope that there exists a unique \(\theta^*\) such that

\[ \theta^* = \underset{\theta\in \Theta}{\text{argmin}}\, d\left[\tilde{p}_{1:n},f(p_{1:n}^\theta)\right]. \] This typically depends on the choice for \(f\) we consider isotonic and linear. Isotonic regression impose monotonicity which is desirable since we believe it would make sense if

\[ p_i > p_j\Rightarrow \tilde{p}_i > \tilde{p}_j. \]

Furthermore isotonic regression is non parametric which mitigate the risk of misspecification. The drawback is overfitting as perfect interpolation of may occur in a small sample size setting.

Well-specified case

In our example we take the following loading fuunctions

\[ f_1(x) = 1.38\cdot x\text{, }f_2(x) = 1.1\cdot x \text{, and } f_3(x) = 1.4\cdot x \]

data <- df_pp[,c("r", "d", "l")]
data["x"] <- c(df_pp$pp[1]*1.38 , df_pp$pp[2]*1.1 , df_pp$pp[3] * 1.4 )
data$x;df_pp$pp

[1] 5.119139 3.742905 5.075182
[1] 3.709521 3.402641 3.625130

# data["x"] <- df_pp$pp
ths_premium <- as.matrix(data[p_p$parm_names])
lambda_true <- 3; mu_true <- 0; sigma_true <- 1
res_iso <- isoreg(df_pp$pp, data$x)

(pp_cp_well_specified <- ggplot() + geom_point(mapping = aes(x = df_pp$pp, y = data$x)) + geom_step(mapping = aes(x= df_pp$pp, y = data$x)) + ggplot2::theme_classic(base_size = 14) + labs(x = "Pure Premium", title = "Commercial premium", y = "") )
ggsave("../figures/pp_cp_well_specified.pdf", pp_cp_well_specified)

Saving 7.29 x 4.51 in image

# Sigma --------------
# Pure premium calculation for a range of risk model parameters
sigmas <- seq(0.1, 2, 0.02)
cloud <- as.matrix(expand.grid(c(3), c(0),sigmas))
colnames(cloud) <- l_m$parm_names
X <- sample_X(l_m , cloud, R = 10000)
pp_fake <- compute_pure_premia(X, coverage_type = "xs", ths_premium)
# Calculation of the RMSE between true and wrong commercial premium
ress_iso <- lapply(1:ncol(pp_fake), function(k) isoreg(pp_fake[, k], data$x))

ress_lm <- sapply(1:ncol(pp_fake), function(k) as.numeric(lm(data$x~pp_fake[, k] - 1)$coefficients))
ress_lm[sigmas == 1]

[1] 1.290995

as.numeric(lm(data$x ~ pp_fake[, sigmas == 1] - 1)$coefficients)

[1] 1.290995

mean((mean((pp_fake[, sigmas == 1] * ress_lm[sigmas == 1] - data$x)^2)^(1/2) - data$x)^2)^(1/2)

[1] 4.215107

fs_iso <- lapply(ress_iso, function(res_iso) stepfun(sort(res_iso$x), c(min(res_iso$yf) /2 ,
                                                                      res_iso$yf), f = 1))
ds_iso <- sapply(1:nrow(cloud), function(k) mean((fs_iso[[k]](pp_fake[, k]) - data$x)^2)^(1/2)) 
ds_lm <- sapply(1:nrow(cloud), function(k) mean((pp_fake[, k] / ress_lm[k] - data$x)^2)^(1/2)) 

df_ds <- data.frame(cloud)
df_ds <- cbind(df_ds, ds_iso)
df_ds <- cbind(df_ds, ds_lm)
(rmse_sigma_iso <- ggplot(data = df_ds) + geom_line(mapping = aes(x = sigma, y = ds_iso)) + ggplot2::theme_classic(base_size = 14) + labs(x = expression(sigma), title = "RMSE", y = "") )
ggsave("../figures/rmse_sigma_iso.pdf", rmse_sigma_iso)

Saving 7.29 x 4.51 in image

(rmse_sigma_linear <- ggplot(data = df_ds) + geom_line(mapping = aes(x = sigma, y = ds_lm)) + ggplot2::theme_classic(base_size = 14) + labs(x = expression(sigma), title = "RMSE", y = ""))
ggsave("../figures/rmse_sigma_linear.pdf", rmse_sigma_linear)

Saving 7.29 x 4.51 in image

# Prior settings for the parameters
prior_lambda <- prior_dist("constant", "lambda",c(3))
prior_mu <- prior_dist("constant", "mu",c(0))
prior_sigma <- prior_dist("uniform", "sigma", c(0, 2))
prior_distributions <- list(prior_lambda, prior_mu, prior_sigma)
model_prior <- independent_priors(prior_distributions)

# Settings for the abc algorithm
popSize <- 2000;  MC_R<- 500; acc <- 0.01; sp_bounds <- c(10^(-16), Inf); eps_min <- 10^-8
res_abc <- abc(data, model_prior, l_m, p_p, popSize, MC_R, acc, sp_bounds, eps_min)

[1] "Sampling generation of particles  1 ; eps =  Inf ; ESS =  2000"
[1] "Sampling generation of particles  2 ; eps =  0.258092889599686 ; ESS =  1001"
=======================================================================================================================================================================================================================================
[1] "Sampling generation of particles  3 ; eps =  0.00110036424142931 ; ESS =  1000.32220779949"

cloud_dfs <- lapply(res_abc$Clouds, as.data.frame)
cloud_df <- do.call(rbind, cloud_dfs)
cloud_df$generation <- sort(rep(1:length(res_abc$Clouds), popSize))
cloud_df_plot <- data.frame(parm = cloud_df$sigma, parm_name = "sigma", generation = cloud_df$generation)

cloud_df_plot$parm_name <-as.factor(cloud_df_plot$parm_name) 
levels(cloud_df_plot$parm_name) <- c(sigma = TeX("$\\sigma$"))
(posterior_sig_iso <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=sigma, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\sigma$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,3]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_sig_iso_supp_mat.pdf", posterior_sig_iso)

Saving 7.29 x 4.51 in image

# Prior settings for the parameters
prior_lambda <- prior_dist("uniform", "lambda",c(0, 5))
prior_mu <- prior_dist("uniform", "mu",c(-3,3))
prior_sigma <- prior_dist("uniform", "sigma", c(0, 2))
prior_distributions <- list(prior_lambda, prior_mu, prior_sigma)
model_prior <- independent_priors(prior_distributions)

# Settings for the abc algorithm
popSize <- 500;  MC_R<- 500; acc <- 0.01; sp_bounds <- c(10^(-16), Inf); eps_min <- 10^(-8)
# res_abc <- abc(data, model_prior, l_m, p_p, popSize, MC_R, acc, sp_bounds, eps_min)
# save(res_abc, file = "../data/res_abc_wo_reg_supp_material_Section2.RData")

load("../data/res_abc_wo_reg_supp_material_Section2.RData")
# We retrieve the cloud of particles associated to each generation
cloud_dfs <- lapply(res_abc$Clouds, as.data.frame)
cloud_df <- do.call(rbind, cloud_dfs)
cloud_df$generation <- sort(rep(1:length(res_abc$Clouds), popSize))
cloud_df_plot <- rbind(
  data.frame(parm = cloud_df$lambda, parm_name = "lambda", generation = cloud_df$generation),
    data.frame(parm = cloud_df$sigma, parm_name = "mu", generation = cloud_df$generation),
  data.frame(parm = cloud_df$sigma, parm_name = "sigma", generation = cloud_df$generation)
)
cloud_df_plot$parm_name <-as.factor(cloud_df_plot$parm_name) 
levels(cloud_df_plot$parm_name) <- c(lambda = TeX("$\\lambda$"), mu = TeX("$\\mu$"),  sigma = TeX("$\\sigma$"))

(posterior_lambda <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=lambda, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\lambda$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,1]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_lambda_wo_reg_supp_mat.pdf", posterior_lambda)

Saving 7.29 x 4.51 in image

(posterior_mu <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=mu, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\mu$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,2]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_mu_wo_reg_supp_mat.pdf", posterior_mu)

Saving 7.29 x 4.51 in image

(posterior_sig <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=sigma, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\sigma$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,3]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_sig_wo_reg_supp_mat.pdf", posterior_sig)

Saving 7.29 x 4.51 in image

# Prior settings for the parameters
prior_lambda <- prior_dist("uniform", "lambda",c(0, 5))
prior_mu <- prior_dist("uniform", "mu",c(-3,3))
prior_sigma <- prior_dist("uniform", "sigma", c(0, 2))
prior_distributions <- list(prior_lambda, prior_mu, prior_sigma)
model_prior <- independent_priors(prior_distributions)

# Settings for the abc algorithm
popSize <- 500;  MC_R<- 500; acc <- 0.001; sp_bounds <- c(min(df_pp$pp / data$x), max(df_pp$pp / data$x))
eps_min <- 0.0001
# res_abc <- abc(data, model_prior, l_m, p_p, popSize, MC_R, acc, sp_bounds, eps_min)
# save(res_abc, file = "../data/res_abc_w_reg_supp_material_Section2.RData")

load("../data/res_abc_w_reg_supp_material_Section2.RData")

# We retrieve the cloud of particles associated to each generation
cloud_dfs <- lapply(res_abc$Clouds, as.data.frame)
cloud_df <- do.call(rbind, cloud_dfs)
cloud_df$generation <- sort(rep(1:length(res_abc$Clouds), popSize))
cloud_df_plot <- rbind(
  data.frame(parm = cloud_df$lambda, parm_name = "lambda", generation = cloud_df$generation),
    data.frame(parm = cloud_df$sigma, parm_name = "mu", generation = cloud_df$generation),
  data.frame(parm = cloud_df$sigma, parm_name = "sigma", generation = cloud_df$generation)
)
cloud_df_plot$parm_name <-as.factor(cloud_df_plot$parm_name) 
levels(cloud_df_plot$parm_name) <- c(lambda = TeX("$\\lambda$"), mu = TeX("$\\mu$"),  sigma = TeX("$\\sigma$"))

(posterior_lambda <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=lambda, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\lambda$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,1]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_lambda_w_reg_supp_mat.pdf", posterior_lambda)

Saving 7.29 x 4.51 in image

(posterior_mu <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=mu, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\mu$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,2]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_mu_w_reg_supp_mat.pdf", posterior_mu)

Saving 7.29 x 4.51 in image

(posterior_sig <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=sigma, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\sigma$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,3]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_sig_w_reg_supp_mat.pdf", posterior_sig)

Saving 7.29 x 4.51 in image

Miss-specified case

In our example we take the following loading fuunctions

\[ f_1(x) = 1.1\cdot x\text{, }f_2(x) = 1.2\cdot x \text{, and } f_3(x) = 1.3\cdot x \]

data <- df_pp[,c("r", "d", "l")]
data["x"] <- c(df_pp$pp[1]*1.1 , df_pp$pp[2]*1.2 , df_pp$pp[3] * 1.3 )
# data["x"] <- df_pp$pp
ths_premium <- as.matrix(data[p_p$parm_names])
lambda_true <- 3; mu_true <- 0; sigma_true <- 1
res_iso <- isoreg(df_pp$pp, data$x)

(pp_cp_miss_specified <- ggplot() + geom_point(mapping = aes(x = df_pp$pp, y = data$x)) + geom_step(mapping = aes(x= df_pp$pp[order(df_pp$pp)], y = res_iso$yf)) + ggplot2::theme_classic(base_size = 14) + labs(x = "Pure Premium", title = "Commercial premium", y = "") )
ggsave("../figures/pp_cp_miss_specified.pdf", pp_cp_miss_specified)

Saving 7.29 x 4.51 in image

res_iso <- isoreg(df_pp$pp, data$x)

# Sigma --------------
# Pure premium calculation for a range of risk model parameters
sigmas <- seq(0.1, 2, 0.02)
cloud <- as.matrix(expand.grid(c(3), c(0),sigmas))
colnames(cloud) <- l_m$parm_names
X <- sample_X(l_m , cloud, R = 10000)
pp_fake <- compute_pure_premia(X, coverage_type = "xs", ths_premium)
# Calculation of the RMSE between true and wrong commercial premium
ress_iso <- lapply(1:ncol(pp_fake), function(k) isoreg(pp_fake[, k], data$x))

ress_lm <- sapply(1:ncol(pp_fake), function(k) as.numeric(lm(data$x~pp_fake[, k] - 1)$coefficients))
ress_lm[sigmas == 1]

[1] 1.193516

as.numeric(lm(data$x ~ pp_fake[, sigmas == 1] - 1)$coefficients)

[1] 1.193516

mean((mean((pp_fake[, sigmas == 1] * ress_lm[sigmas == 1] - data$x)^2)^(1/2) - data$x)^2)^(1/2)

[1] 4.003783

fs_iso <- lapply(ress_iso, function(res_iso) stepfun(sort(res_iso$x), c(min(res_iso$yf) /2 ,
                                                                      res_iso$yf), f = 1))
ds_iso <- sapply(1:nrow(cloud), function(k) mean((fs_iso[[k]](pp_fake[, k]) - data$x)^2)^(1/2)) 
ds_lm <- sapply(1:nrow(cloud), function(k) mean((pp_fake[, k] / ress_lm[k] - data$x)^2)^(1/2)) 

df_ds <- data.frame(cloud)
df_ds <- cbind(df_ds, ds_iso)
df_ds <- cbind(df_ds, ds_lm)
(rmse_sigma_iso <- ggplot(data = df_ds) + geom_line(mapping = aes(x = sigma, y = ds_iso)) + ggplot2::theme_classic(base_size = 14) + labs(x = expression(sigma), title = "RMSE", y = "") )
ggsave("../figures/rmse_sigma_iso_miss.pdf", rmse_sigma_iso)

Saving 7.29 x 4.51 in image

(rmse_sigma_linear <- ggplot(data = df_ds) + geom_line(mapping = aes(x = sigma, y = ds_lm)) + ggplot2::theme_classic(base_size = 14) + labs(x = expression(sigma), title = "RMSE", y = ""))
ggsave("../figures/rmse_sigma_linear_miss.pdf", rmse_sigma_linear)

Saving 7.29 x 4.51 in image

# Prior settings for the parameters
prior_lambda <- prior_dist("uniform", "lambda",c(0,5))
prior_mu <- prior_dist("uniform", "mu",c(-3,3))
prior_sigma <- prior_dist("uniform", "sigma", c(0, 2))
prior_distributions <- list(prior_lambda, prior_mu, prior_sigma)
model_prior <- independent_priors(prior_distributions)

# Settings for the abc algorithm
popSize <- 500;  MC_R<- 500; acc <- 0.01; sp_bounds <- c(10^(-16), Inf); eps_min <- 0.0001
# res_abc <- abc(data, model_prior, l_m, p_p, popSize, MC_R, acc, sp_bounds, eps_min)
# save(res_abc, file = "../data/res_abc_wo_reg_miss_supp_material_Section2.RData")

load("../data/res_abc_wo_reg_miss_supp_material_Section2.RData")

# We retrieve the cloud of particles associated to each generation
cloud_dfs <- lapply(res_abc$Clouds, as.data.frame)
cloud_df <- do.call(rbind, cloud_dfs)
cloud_df$generation <- sort(rep(1:length(res_abc$Clouds), popSize))
cloud_df_plot <- rbind(
  data.frame(parm = cloud_df$lambda, parm_name = "lambda", generation = cloud_df$generation),
    data.frame(parm = cloud_df$sigma, parm_name = "mu", generation = cloud_df$generation),
  data.frame(parm = cloud_df$sigma, parm_name = "sigma", generation = cloud_df$generation)
)
cloud_df_plot$parm_name <-as.factor(cloud_df_plot$parm_name) 
levels(cloud_df_plot$parm_name) <- c(lambda = TeX("$\\lambda$"), mu = TeX("$\\mu$"),  sigma = TeX("$\\sigma$"))

(posterior_lambda <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=lambda, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\lambda$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,1]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_lambda_wo_reg_miss_supp_mat.pdf", posterior_lambda)

Saving 7.29 x 4.51 in image

(posterior_mu <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=mu, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\mu$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,2]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_mu_wo_reg_miss_supp_mat.pdf", posterior_mu)

Saving 7.29 x 4.51 in image

(posterior_sig <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=sigma, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\sigma$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,3]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_sig_wo_reg_miss_supp_mat.pdf", posterior_sig)

Saving 7.29 x 4.51 in image

# Prior settings for the parameters
prior_lambda <- prior_dist("uniform", "lambda",c(0, 5))
prior_mu <- prior_dist("uniform", "mu",c(-3,3))
prior_sigma <- prior_dist("uniform", "sigma", c(0, 2))
prior_distributions <- list(prior_lambda, prior_mu, prior_sigma)
model_prior <- independent_priors(prior_distributions)

# Settings for the abc algorithm
popSize <- 500;  MC_R<- 500; acc <- 0.001; sp_bounds <- c(min(df_pp$pp / data$x), max(df_pp$pp / data$x))
eps_min <- 0.01
# res_abc <- abc(data, model_prior, l_m, p_p, popSize, MC_R, acc, sp_bounds, eps_min)
# save(res_abc, file = "../data/res_abc_w_reg_miss_supp_material_Section2.RData")

load("../data/res_abc_w_reg_miss_supp_material_Section2.RData")
# We retrieve the cloud of particles associated to each generation
cloud_dfs <- lapply(res_abc$Clouds, as.data.frame)
cloud_df <- do.call(rbind, cloud_dfs)
cloud_df$generation <- sort(rep(1:length(res_abc$Clouds), popSize))
cloud_df_plot <- rbind(
  data.frame(parm = cloud_df$lambda, parm_name = "lambda", generation = cloud_df$generation),
    data.frame(parm = cloud_df$sigma, parm_name = "mu", generation = cloud_df$generation),
  data.frame(parm = cloud_df$sigma, parm_name = "sigma", generation = cloud_df$generation)
)
cloud_df_plot$parm_name <-as.factor(cloud_df_plot$parm_name) 
levels(cloud_df_plot$parm_name) <- c(lambda = TeX("$\\lambda$"), mu = TeX("$\\mu$"),  sigma = TeX("$\\sigma$"))

(posterior_lambda <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=lambda, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\lambda$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,1]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_lambda_w_reg_miss_supp_mat.pdf", posterior_lambda)

Saving 7.29 x 4.51 in image

(posterior_mu <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=mu, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\mu$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,2]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_mu_w_reg_miss_supp_mat.pdf", posterior_mu)

Saving 7.29 x 4.51 in image

(posterior_sig <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=sigma, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\sigma$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,3]), color="black",
                                   linetype="dashed"))
ggsave("../figures/posterior_sig_w_reg_miss_supp_mat.pdf", posterior_sig)

Saving 7.29 x 4.51 in image

(posterior_lambda <- ggplot2::ggplot(data = cloud_df ) + ggplot2::geom_density(data = cloud_df, mapping = aes(x=lambda, color = as.factor(generation))) + ggplot2::labs(x=TeX("$\\lambda$"), y = "Density", color = "Generation") + ggplot2::theme_classic(base_size = 20) + ggplot2::theme(legend.position="right") + ggplot2::geom_vline(ggplot2::aes(xintercept=true_parms[,1]), color="black",
                                   linetype="dashed"))